
proc scanLocations {imageArray powerArray mapFileSpec bbox locators {informNames 0}} {
	set eNumber "\[-\]?\[0-9.\]+"
	set eDefine "bd|def|bind def"
	set eTerritory "\\w{3}"
	set eProvince "\\w{3}|\\w{3}/\\w{2}"

	set infoLocators []
	set tlaLocators []
	set drawLocators []
	set countryLocators []
	
	foreach {locatorName locatorType} $locators {
		switch -- $locatorType INFO {
			lappend infoLocators $locatorName
		} TLA {
			lappend tlaLocators $locatorName
		} DRAW {
			lappend drawLocators $locatorName
		} COUNTRY {
			lappend countryLocators $locatorName
		} default {
			inform "Locator type $locatorType for $locatorName unknown. Choose between INFO, TLA, DRAW or COUNTRY. Skipped."
		}
	} 

	if {![llength $infoLocators] && ![llength $tlaLocators] && ![llength $drawLocators] && ![llength $countryLocators]} {
		return
	}

	set I [iexpect::Expect #auto -white -file $mapFileSpec]

	if {[llength $infoLocators]} {
		# Create image containing a single curve, connecting all points.
		set image [iarray::code [Image #auto [list operator fk connected 1]]]
		if {[llength $bbox]} {
			eval [list $image setBBox] $bbox
		}
		set locations {}
		set longNames {}
		$I expect line "^$" {
			$I continue
		} "^%\[!%\]" {
			$I continue
		} "^% INFO$" {
			$I expect line "^$" {
				$I continue
			} "^% ($eNumber) ($eNumber) ($eProvince) (.+)$" {
				if {[$image isEmpty]} {
					$image moveTo [list [$I get match 1] [$I get match 2]]
				} else {
					$image lineTo [list [$I get match 1] [$I get match 2]]
				}
				lappend locations [string toupper [$I get match 3]]
				lappend longNames [$I get match 4]
				$I continue
			} "^% MAP$" {
			} default {
				assert false {Unexpected line in INFO part of $mapFileSpec: [$I get output]}
			}
		} default {
			# Not found
			inform "No INFO information in file $mapFileSpec found."
		}
		if {[$image isEmpty]} {
			itcl::delete object $image
		} else {
			if {$informNames} {
				inform "PS territories: [Story::hexify [string toupper $locations]]"
			}
			$image updateAttributes [list locations $locations longNames $longNames]
			set first true
			foreach locatorName $infoLocators {
				if {$first} {
					$imageArray acquire $locatorName $image
					set first false
				} else {
					$imageArray set $locatorName $image
				}
			}
		}
	}
	
	set patternList []
	if {[llength $tlaLocators]} {
		# Create image containing a single curve, connecting all points.
		set tlaImage [iarray::code [Image #auto [list operator fk connected 1]]]
		if {[llength $bbox]} {
			eval [list $tlaImage setBBox] $bbox
		}
		set tlaLocations {}
		lappend patternList "^/($eTerritory) ?\\\{ ?($eNumber) ($eNumber) ?\\\} ?($eDefine)( %|$)" {
			if {[string equal [string toupper [$I get match 1]] [$I get match 1]]} {
				if {[$tlaImage isEmpty]} {
					$tlaImage moveTo [list [$I get match 2] [$I get match 3]]
				} else {
					$tlaImage lineTo [list [$I get match 2] [$I get match 3]]
				}
				lappend tlaLocations [$I get match 1]
			}
			$I continue
		}
	}
	if {[llength $drawLocators]} {
		# Create image containing lots of small curves, each representing one connection.
		# Most curves will consist of only two points, but if the end point of the previous
		# connection and that of the new connection are the same, they're bundled into the 
		# same curve.
		set drawImage [iarray::code [Image #auto [list operator fk connected 2]]]
		if {[llength $bbox]} {
			eval [list $drawImage setBBox] $bbox
		}
		lappend patternList "^($eNumber) ($eNumber) ($eNumber) ($eNumber) (.+ )?Draw\\w*Connection( %|$)" {
			if {[$drawImage isEmpty] || ![$drawImage isSameEndPoint [list [$I get match 1] [$I get match 2]]]} {
				$drawImage moveTo [list [$I get match 1] [$I get match 2]]
			}
			$drawImage lineTo [list [$I get match 3] [$I get match 4]]
			$I continue
		}
	}
	if {[llength $countryLocators]} {
		set initials {}
		array set colors {}
		array set countries {}
		set painters {}
		lappend patternList "^/Countries \\\[( %|$)" {
			$I expect line "^(\\(.\\)( \\(.\\))*)( %|$)" {
				eval lappend initials [lapply [$I get match 1] "string index" 1]
				$I continue
			} "^\\\] ($eDefine)( %|$)" {
			} default {
				assert false {Unexpected line in Countries definition of $mapFileSpec: [$I get output]}
			}
			$I continue
		} "^/(\\w+)Colou?rs ?\[\[\\\{\] ?/(\\w+) /(\\w+) ?\[\]\\\}\] ?($eDefine)( %|$)" {
			set colors([$I get match 1]) "[$I get match 2] [$I get match 3]"
			$I continue
		} "^/(\\w+) ?\\\{ ?(\\d+) ((\\w+)Colou?rs )?set_country ?\\\} ?($eDefine)( %|$)" {
			set countries([$I get match 1]) "[$I get match 2] [$I get match 4]"
			$I continue
		} "^/CountryColou?rs \\\[( %|$)" {
			$I expect line "^(\\w+)Colou?rs( %|$)" {
				lappend painters [$I get match 1]
				$I continue
			} "^\\\] ($eDefine)( %|$)" {
			} default {
				assert false {Unexpected line in CountryColours definition of $mapFileSpec: [$I get output]}
			}
			$I continue
		}
	}
	
	if {[llength $patternList]} {
		lappend patternList default {
			$I continue
		}
		eval [list $I expect line] $patternList
		if {[llength $tlaLocators]} {
			if {[$tlaImage isEmpty]} {
				itcl::delete object $tlaImage
			} else {
				if {$informNames} {
					inform "PS supply centers: [Story::hexify [string toupper $tlaLocations]]"
				}
				$tlaImage updateAttributes [list locations $tlaLocations]
				set first true
				foreach locatorName $tlaLocators {
					if {$first} {
						$imageArray acquire $locatorName $tlaImage
						set first false
					} else {
						$imageArray set $locatorName $tlaImage
					}
				}
			}
		}
		if {[llength $drawLocators]} {
			if {[$drawImage isEmpty]} {
				itcl::delete object $drawImage
			} else {
				set first true
				foreach locatorName $drawLocators {
					if {$first} {
						$imageArray acquire $locatorName $drawImage
						set first false
					} else {
						$imageArray set $locatorName $drawImage
					}
				}
			}
		}
		if {[llength $countryLocators]} {
			array set indexedPowers {}
			foreach {power details} [array get countries] {
				foreach {idx painter} $details {
					if {![string length $painter]} {
						set painter [lindex $painters $idx]
					}
					set indexedPowers($idx) "[list $power [eval list [lindex $initials $idx] $colors($painter)]]"
				}
			}
			set orderedPowers {}
			set powerNames {}
			# At this point powerArray should still be empty. Merging will happen later.
			foreach idx [lsort -integer [array names indexedPowers]] {
				$powerArray set $indexedPowers($idx)
			}
		}
	}
	
	itcl::delete object $I
}

proc scanMap {imageArray powerArray mapFileSpec mapFileEncoding informNames bbox {locators {}} {mapParts {}} {operators {}} {colors {}}} {
	set mapFileSpec [absolve $mapFileSpec]
	if {![file exists $mapFileSpec]} {
		inform "Scan map file $mapFileSpec not found"
		return $imageArray
	}

	if {[llength $locators]} {
		scanLocations $imageArray $powerArray $mapFileSpec $bbox $locators $informNames
	}
	if {![llength $mapParts]} {
		return
	}
	
	set eNumber "\[-\]?\[0-9.\]+"
	set eName "\[^ \]+"
	set eDefine "bd|def|bind def"
	set eLoad "ld|load def"
	set eEOL "( %|$)"
	set eEOR "( |$)"

	array set eOperators ""
	array set eNumbers ""
	array set eColors ""
	array set eColorCombos ""
	foreach cmd {
		newpath closepath moveto lineto curveto arc arcn fill eofill stroke setbbox nil pop
	} {
		set eOperators($cmd) [list $cmd]
	}
	lappend eOperators(nil) \
		translate rotate scale gsave grestore setlinewidth setmiterlimit setdash
	foreach {operator cmd} $operators {
		switch [llength $cmd] 0 {
			lappend eOperators(nil) $operator
		} 1 {
			if {[string is double $cmd]} {
				set eNumbers($operator) $cmd
			} else {
				assert {[info exists eOperators($cmd)]} {Operator $cmd unknown}
				lappend eOperators($cmd) $operator
			}
		} 2 {
			assert {[info exists eOperators([lindex $cmd 1])]} {Operator [lindex $cmd 1] in <$cmd> unknown}
			assert {![info exists eOperators([lindex $cmd 0])]} {Color [lindex $cmd 0] in <$cmd> should not be an operator}
			lappend eOperators([lindex $cmd 1]) $operator
			switch [lindex $cmd 1] stroke {
			} fill {
			} eofill {
			} default {
				assert false {Two part command <$cmd> should consist of a color, followed by stroke or fill}
			}
			set eColors($operator) [lindex $cmd 0]
		} default {
			assert false {Command <$cmd> has more than 2 parts}
		}
	}

	set allRenderers [concat $eOperators(stroke) $eOperators(fill) $eOperators(eofill)]
	set allColors {}
	foreach operator [array names eColors] {
		if {[lsearch $allColors $eColors($operator)] < 0} {
			lappend allColors $eColors($operator)
		}
	}
	
	foreach {color operators} $colors {
		if {[lsearch $allColors $color] < 0} {
			lappend allColors $color
		}
		foreach operator $operators {
			switch [llength $operator] 0 {
			} 1 {
				assert {[lsearch $allRenderers $operator] >= 0} {Color operator $operator for color $color is not a stroke or fill operator}
				set eColorCombos($color%$operator) $color
			} default {
				set recolor [lindex $operator 0]
				assert {[lsearch $allRenderers $recolor] < 0} {Recolored color $recolor for color $color is a stroke or fill operator}
				if {[lsearch $allColors $recolor] < 0} {
					lappend allColors $recolor
				}
				foreach reoperator [lrange $operator 1 end] {
					assert {[lsearch $allRenderers $reoperator] >= 0} {Recolored operator $reoperator for color $color is not a stroke or fill operator}
					set eColorCombos($color%$reoperator) $recolor
				}
			}
		}
	}
	
	proc returnNumber {number} {return $number}
	proc lookupNumber {number} {
		upvar eNumbers eNumbers
		if {[info exists eNumbers($number)]} {
			return $eNumbers($number)
		} else {
			return $number
		}
	}
	if {[llength [array names eNumbers]]} {
		set eNumber "$eNumber|[Story::chooseBetween [array names eNumbers]]"
		set extractNumber lookupNumber 
	} else {
		set extractNumber returnNumber
	}

	set parts {}
	set subparts {}
	foreach part $mapParts {
		switch [llength $part] 0 {
		} 1 {
			lappend parts $part
		} default {
			set cmd [lindex $part end]
			set part [lrange $part 0 end-1]
			assert {[lsearch $allRenderers $cmd] >= 0} {Last subpart $cmd of <$part> is not a stroke or fill command}
			if {![info exists eColors($cmd)]} {
				assert {[info exists eColorCombos([lindex $part 0]%$cmd)]} {Color [lindex $part 0] of <$part> does not combine with render command $cmd in the color definitions}
				set part [lrange $part 1 end]
			}
			foreach subpart $part {
				assert {[lsearch $allColors $subpart] < 0} {In between subpart $subpart is a color}
				assert {[lsearch $allRenderers $subpart] < 0} {In between subpart $subpart is a stroke or fill command}
				if {[lsearch $subparts $subpart] < 0} { 
					lappend subparts $subpart
				}
			}
		}
	}

	if {[llength $parts]} {
		set image [iarray::code [Image #auto [list bbox $bbox operator fk]]]
	} else {
		set image {}
	}
	if {[llength $subparts]} {
		set subimage [iarray::code [Image #auto [list bbox $bbox operator fk]]]	
	} else {
		set subimage {}
	}
	set suborder {}
	
	set I [iexpect::Expect #auto -white -file $mapFileSpec -encoding $mapFileEncoding]
	$I expect line "^/([Story::chooseBetween [concat $parts $subparts]])(| \\\{)?$eEOL" {
		set part [$I get match 1]
		set isSub [expr ([lsearch $subparts $part] >= 0)] 
		if {![string length [$I get match 2]]} {
			$I expect raw "^\\\{" {
			} default {
				assert false {No opening bracket after $part}
			}
		}

		set colorImage {}
		set curving 0
		set precolor {}
		set skippedBlocks 0
		set closed 0
		set openLineNr [$I get line_nr]
		
		$I expect raw "^(/($eName) )?(\[\[\{\])" {
			set openBrace [$I get match 3]
			switch $openBrace "\{" {
				set closeBrace "\}"
			} default {
				set closeBrace "\]"
			}
			set open 1
			set openLineNr [$I get line_nr]
			set define [$I get match 2]
			$I expect raw "\[$openBrace\]" {
				incr open
				$I continue
			} "\[$closeBrace\]" {
				incr open -1
				if {$open} {
					$I continue
				} elseif {[string length $define]} {
					$I expect raw "^($eDefine)$eEOR" {
					} "" {
						inform "No define statement for procedure $define in part $part on line [$I get nr_line]"
					}
				} else {
					$I expect raw "^(pop|exec)$eEOR" {
					} "^($eDefine)$eEOR" {
						inform "Define statement withouth procedure name for part $part on line [$I get nr_line]"
					} "" {
					}
					incr skippedBlocks
				}
			} "%" {
				$I expect line default {}
				$I continue
			}
			$I continue
		} "^/($eName) ($eNumber) ($eDefine)$eEOR" {
			$I continue
		} "^/($eName) ?/($eName) ($eLoad)$eEOR" {
			$I continue
		} "^\\\} ($eDefine)$eEOR" {
			set closed 1
			# No further continuation
		} "^\\\}" {
			set closed 1
			inform "No def statement after closing bracket for part $part on line [$I get nr_line]"
			# No further continuation
		} "^(pop|$eDefine)$eEOR" {
			assert false {Has def or pop statement before closing bracket on line [$I get nr_line]}
			$I continue
		} "^%" {
			$I expect line default {}
			$I continue
		} "^([Story::chooseBetween $allColors])$eEOR" {
			assert {!$isSub} {Color [$I get match 1] set inside subpart $part on line [$I get nr_line]}
			#assert {!$curving} {Color change inside curve on line [$I get nr_line]}
			set precolor [$I get match 1]
			$I continue
		} "^($eNumber) ($eNumber) ($eNumber) ($eNumber) ([Story::chooseBetween $eOperators(setbbox)])$eEOR" {
			$I continue
		} "^([Story::chooseBetween $eOperators(newpath)])$eEOR" {
			assert {$curving == 0} {Has newpath inside curve on line [$I get nr_line]}
			set curving 1
			if {$isSub} {
				$subimage newPath
			} else {
				$image newPath
			}
			$I continue
		} "^($eNumber) ($eNumber) ([Story::chooseBetween $eOperators(moveto)])$eEOR" {
			if {$isSub} {
				assert {$curving == 0} {Has moveto not at start inside subpart $part on line [$I get nr_line]}
				lappend suborder $part
				$subimage moveTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]]
			} else {
				#assert {$curving <= 1} {Has moveto inside curve on line [$I get nr_line]}
				$image moveTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]]
			}
			set curving 2
			$I continue
		} "^($eNumber) ($eNumber) ([Story::chooseBetween $eOperators(lineto)])$eEOR" {
			if {$isSub} {
				if {$curving < 2} {
					lappend suborder $part
					$subimage moveTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]]
					set curving 2
				} else {
					$subimage lineTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]]
				}
			} else {
				assert {$curving == 2} {Has lineto outside curve on line [$I get nr_line]}
				$image lineTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]]
			}
			$I continue
		} "^($eNumber) ($eNumber) ($eNumber) ($eNumber) ($eNumber) ($eNumber) ([Story::chooseBetween $eOperators(curveto)])$eEOR" {
			if {$isSub} {
				assert {$curving == 2} {Has curveto outside curve inside subpart $part on line [$I get nr_line]}
				$subimage curveTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]] [list [$extractNumber [$I get match 3]] [$extractNumber [$I get match 4]]] [list [$extractNumber [$I get match 5]] [$extractNumber [$I get match 6]]]
			} else {
				assert {$curving == 2} {Has curveto outside curve on line [$I get nr_line]}
				$image curveTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]] [list [$extractNumber [$I get match 3]] [$extractNumber [$I get match 4]]] [list [$extractNumber [$I get match 5]] [$extractNumber [$I get match 6]]]
			}
			$I continue
		} "^($eNumber) ($eNumber) ($eNumber) ($eNumber) ($eNumber) ([Story::chooseBetween $eOperators(arc)])$eEOR" {
			if {$isSub} {
				$subimage arcTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]] [$extractNumber [$I get match 3]] [$extractNumber [$I get match 4]] [$extractNumber [$I get match 5]] 0
			} else {
				$image arcTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]] [$extractNumber [$I get match 3]] [$extractNumber [$I get match 4]] [$extractNumber [$I get match 5]] 0
			}
			set curving 2
			$I continue
		} "^($eNumber) ($eNumber) ($eNumber) ($eNumber) ($eNumber) ([Story::chooseBetween $eOperators(arcn)])$eEOR" {
			if {$isSub} {
				$subimage arcTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]] [$extractNumber [$I get match 3]] [$extractNumber [$I get match 4]] [$extractNumber [$I get match 5]] 1
			} else {
				$image arcTo [list [$extractNumber [$I get match 1]] [$extractNumber [$I get match 2]]] [$extractNumber [$I get match 3]] [$extractNumber [$I get match 4]] [$extractNumber [$I get match 5]] 1
			}
			set curving 2
			$I continue
		} "^([Story::chooseBetween $eOperators(closepath)])$eEOR" {
			assert {!$isSub} {No closepath should occur inside subpart $part on line [$I get nr_line]}
			assert {$curving == 2} {Has closepath outside curve on line [$I get nr_line]}
			$image closePath
			set curving 3
			$I continue
		} "^([Story::chooseBetween $allRenderers])$eEOR" {
			assert {!$isSub} {No fill or stroke should occur inside subpart $part on line [$I get nr_line]}
			assert {$curving >= 2} {Has fill or stroke outside curve on line [$I get nr_line]}
			set cmd [$I get match 1]
			if {($curving < 3) && ([lsearch $eOperators(stroke) $cmd] < 0)} {
				$image closePath
			}
			set color ""
			if {[info exists eColors($cmd)]} {
				set color $eColors($cmd)
			} else {
				if {![string length $precolor]} {
					inform "Color not set for render command $cmd on line [$I get nr_line]"
				} elseif {![info exists eColorCombos($precolor%$cmd)]} {
					inform "No match between color $precolor and render command $cmd on line [$I get nr_line]"
				} else {
					set color $eColorCombos($precolor%$cmd)
				}
			}
			if {[string length $color]} {
				if [$imageArray has $color] {
					set colorImage [$imageArray of $color]
				} else {
					set colorImage [iarray::code [Image #auto [list bbox $bbox operator fk]]]
					$imageArray acquire $color $colorImage
				}
				$colorImage addCurves [$image getCurves]
			}
			$image clearCurves
			set curving 0
			$I continue
		} "^(($eNumber|\[\]\[\]) )*([Story::chooseBetween $eOperators(nil)])$eEOR" {
			$I continue
		} "^(($eNumber|\[\]\[\]) )*($eName)$eEOR" {
			inform "Unrecognized command [$I get match 3] on line [$I get nr_line]"
			$I continue
		}

		assert {$closed} {No closing bracket for part $part, last one opened on line $openLineNr, $open open, currently on line [$I get nr_line].}
		
		if {$skippedBlocks} {
			inform "Skipped $skippedBlocks blocks in part $part"
		}
		
		$I continue
	} default {
		$I continue
	}

	if {[string length $image]} {itcl::delete object $image}

	if {[llength $subparts]} {
		set subcurves [$subimage getCurves]
		foreach part $mapParts {
			if {[llength $part] > 1} {
				set cmd [lindex $part end]
				set part [lrange $part 0 end-1]
				if {[info exists eColors($cmd)]} {
					set color $eColors($cmd)
				} else {
					set color $eColorCombos([lindex $part 0]%$cmd)
					set part [lrange $part 1 end]
				}
				if {[$imageArray has $color]} {
					set colorImage [$imageArray of $color]
				} else {
					set colorImage [iarray::code [Image #auto [list bbox $bbox operator fk]]]
					$imageArray acquire $color $colorImage
				}
				set curve {}
				foreach subpart $part {
					set idx [lsearch $suborder $subpart]
					if {$idx < 0} {
						inform "Subpart $subpart not defined. Skipping."
						continue
					}
					set subcurve [lindex $subcurves $idx]
					if {![string length $curve]} {
						set curve [Curve #auto [$subcurve getStartPoint]]
					} else {
						$curve lineTo [$subcurve getStartPoint]
					}
					$curve connectSelf $subcurve
				}
				if {[string length $curve]} {
					$colorImage addCurves [list $curve]
				}
			}
		}
	}

	if {[string length $subimage]} {itcl::delete object $subimage}
	
	inform "Scanned"
	
	itcl::delete object $I
}
